home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH5 / SRC / DISSOLVE.FRM (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1997-01-08  |  9.0 KB  |  299 lines

  1. VERSION 4.00
  2. Begin VB.Form DissolveForm 
  3.    Caption         =   "Dissolve"
  4.    ClientHeight    =   3840
  5.    ClientLeft      =   1635
  6.    ClientTop       =   1230
  7.    ClientWidth     =   4890
  8.    Height          =   4530
  9.    Left            =   1575
  10.    LinkTopic       =   "Form1"
  11.    ScaleHeight     =   256
  12.    ScaleMode       =   3  'Pixel
  13.    ScaleWidth      =   326
  14.    Top             =   600
  15.    Width           =   5010
  16.    Begin VB.CommandButton CmdDissolve 
  17.       Caption         =   "Dissolve"
  18.       Height          =   495
  19.       Left            =   0
  20.       TabIndex        =   3
  21.       Top             =   0
  22.       Width           =   975
  23.    End
  24.    Begin VB.PictureBox Canvas 
  25.       AutoRedraw      =   -1  'True
  26.       Height          =   3810
  27.       Left            =   1080
  28.       Picture         =   "DISSOLVE.frx":0000
  29.       ScaleHeight     =   250
  30.       ScaleMode       =   3  'Pixel
  31.       ScaleWidth      =   250
  32.       TabIndex        =   2
  33.       Top             =   0
  34.       Width           =   3810
  35.    End
  36.    Begin VB.PictureBox Pict 
  37.       AutoRedraw      =   -1  'True
  38.       AutoSize        =   -1  'True
  39.       Height          =   3810
  40.       Index           =   1
  41.       Left            =   120
  42.       Picture         =   "DISSOLVE.frx":FA5A
  43.       ScaleHeight     =   250
  44.       ScaleMode       =   3  'Pixel
  45.       ScaleWidth      =   250
  46.       TabIndex        =   1
  47.       Top             =   3840
  48.       Visible         =   0   'False
  49.       Width           =   3810
  50.    End
  51.    Begin VB.PictureBox Pict 
  52.       AutoRedraw      =   -1  'True
  53.       AutoSize        =   -1  'True
  54.       Height          =   3810
  55.       Index           =   0
  56.       Left            =   0
  57.       Picture         =   "DISSOLVE.frx":1F4B4
  58.       ScaleHeight     =   250
  59.       ScaleMode       =   3  'Pixel
  60.       ScaleWidth      =   250
  61.       TabIndex        =   0
  62.       Top             =   3720
  63.       Visible         =   0   'False
  64.       Width           =   3810
  65.    End
  66.    Begin VB.Menu mnuFile 
  67.       Caption         =   "&File"
  68.       Begin VB.Menu mnuFileExit 
  69.          Caption         =   "E&xit"
  70.       End
  71.    End
  72. Attribute VB_Name = "DissolveForm"
  73. Attribute VB_Creatable = False
  74. Attribute VB_Exposed = False
  75. Option Explicit
  76. Dim SysPalSize As Integer
  77. Dim NumStaticColors As Integer
  78. Dim StaticColor1 As Integer
  79. Dim StaticColor2 As Integer
  80. Dim ActiveImage As Integer
  81. ' ***********************************************
  82. ' Give the form and all the picture boxes an
  83. ' hourglass cursor.
  84. ' ***********************************************
  85. Sub WaitStart()
  86.     MousePointer = vbHourglass
  87.     Canvas.MousePointer = vbHourglass
  88.     DoEvents
  89. End Sub
  90. ' ***********************************************
  91. ' Restore the mouse pointers for the form and all
  92. ' the picture boxes.
  93. ' ***********************************************
  94. Sub WaitEnd()
  95.     MousePointer = vbDefault
  96.     Canvas.MousePointer = vbDefault
  97. End Sub
  98. ' ************************************************
  99. ' Dissolve fpic into tpic.
  100. ' ************************************************
  101. Sub Dissolve(fpic As Control, tpic As Control)
  102. Dim bm As BITMAP
  103. Dim hbm As Integer
  104. Dim wid As Long
  105. Dim hgt As Long
  106. Dim newbytes() As Byte
  107. Dim fbytes() As Byte
  108. Dim tbytes() As Byte
  109. Dim status As Long
  110. Dim ffrac As Single
  111. Dim tfrac As Single
  112. Dim i As Integer
  113. Dim j As Integer
  114. Dim num As Integer
  115.     ' Get the new image's pixels.
  116.     hbm = tpic.Image
  117.     status = GetObject(hbm, BITMAP_SIZE, bm)
  118.     wid = bm.bmWidthBytes
  119.     hgt = bm.bmHeight
  120.     ReDim tbytes(1 To wid, 1 To hgt)
  121.     status = GetBitmapBits(hbm, wid * hgt, tbytes(1, 1))
  122.     ' Get the old image's pixels.
  123.     hbm = fpic.Image
  124.     status = GetObject(hbm, BITMAP_SIZE, bm)
  125.     wid = bm.bmWidthBytes
  126.     hgt = bm.bmHeight
  127.     ReDim fbytes(1 To wid, 1 To hgt)
  128.     status = GetBitmapBits(hbm, wid * hgt, fbytes(1, 1))
  129.     ' Make room for the new image
  130.     ReDim newbytes(1 To wid, 1 To hgt)
  131.     For ffrac = 1# To 0# Step -0.05
  132.         tfrac = 1# - ffrac
  133.         For i = 1 To wid
  134.             For j = 1 To wid
  135.                 newbytes(i, j) = _
  136.                     NearestNonstaticGray( _
  137.                         ffrac * fbytes(i, j) + _
  138.                         tfrac * tbytes(i, j))
  139.             Next j
  140.         Next i
  141.             
  142.         status = SetBitmapBits(hbm, wid * hgt, newbytes(1, 1))
  143.         fpic.Refresh
  144.         
  145.         SavePicture fpic.Image, "Diss_" & Format$(num) & ".bmp"
  146.         num = num + 1
  147.         
  148.         DoEvents
  149.     Next ffrac
  150. End Sub
  151. ' ************************************************
  152. ' Dissolve the new image onto the old.
  153. ' ************************************************
  154. Private Sub CmdDissolve_Click()
  155.     ActiveImage = 1 - ActiveImage
  156.     WaitStart
  157.     Dissolve Canvas, Pict(ActiveImage)
  158.     WaitEnd
  159. End Sub
  160. Private Sub Form_Load()
  161.     Randomize
  162.     ' Make sure the screen supports palettes.
  163.     If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
  164.         Beep
  165.         MsgBox "This monitor does not support palettes.", _
  166.             vbCritical
  167.         End
  168.     End If
  169.     ' Get system palette size and # static colors.
  170.     SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
  171.     NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
  172.     StaticColor1 = NumStaticColors \ 2 - 1
  173.     StaticColor2 = SysPalSize - NumStaticColors \ 2
  174.     ' Get the bitmaps' bits.
  175.     Me.Show
  176.     WaitStart
  177.     MatchGrayPalette Canvas
  178.     MatchGrayPalette Pict(0)
  179.     MatchGrayPalette Pict(1)
  180.     Canvas.ZOrder
  181.     DoEvents
  182.     Pict(0).ZOrder
  183.     DoEvents
  184.     Pict(1).ZOrder
  185.     DoEvents
  186.     WaitEnd
  187. End Sub
  188. ' ************************************************
  189. ' Return the index of the nonstatic gray closest
  190. ' to the given value (assuming the non-static
  191. ' colors are a gray scale created by
  192. ' MatchGrayPalette).
  193. ' ************************************************
  194. Function NearestNonstaticGray(c As Integer) As Integer
  195. Dim dgray As Single
  196.     If c < 0 Then
  197.         c = 0
  198.     ElseIf c > 255 Then
  199.         c = 255
  200.     End If
  201.     dgray = 255 / (StaticColor2 - StaticColor1 - 2)
  202.     NearestNonstaticGray = c / dgray + StaticColor1 + 1
  203. End Function
  204. ' ***********************************************
  205. ' Load the control's palette so the non-static
  206. ' colors are grays. Map the logical palette to
  207. ' match the system palette. Convert the image to
  208. ' use the non-static grays.
  209. ' ***********************************************
  210. Sub MatchGrayPalette(pic As Control)
  211. Dim logpal As Integer
  212. Dim sys(0 To 255) As PALETTEENTRY
  213. Dim palentry(0 To 255) As PALETTEENTRY
  214. Dim i As Integer
  215. Dim bm As BITMAP
  216. Dim hbm As Integer
  217. Dim status As Long
  218. Dim x As Integer
  219. Dim y As Integer
  220. Dim gray As Single
  221. Dim dgray As Single
  222. Dim c As Integer
  223. Dim clr As Integer
  224. Dim wid As Long
  225. Dim hgt As Long
  226. Dim bytes() As Byte
  227.     ' Make sure pic has the foreground palette.
  228.     pic.ZOrder
  229.     i = RealizePalette(pic.hdc)
  230.     DoEvents
  231.     ' Get the system palette entries.
  232.     i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))
  233.         
  234.     ' Get the image pixels.
  235.     hbm = pic.Image
  236.     status = GetObject(hbm, BITMAP_SIZE, bm)
  237.     wid = bm.bmWidthBytes
  238.     hgt = bm.bmHeight
  239.     ReDim bytes(1 To wid, 1 To hgt)
  240.     status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
  241.     ' Make the logical palette as big as possible.
  242.     logpal = pic.Picture.hPal
  243.     If ResizePalette(logpal, SysPalSize) = 0 Then
  244.         Beep
  245.         MsgBox "Error resizing logical palette.", _
  246.             vbExclamation
  247.         Exit Sub
  248.     End If
  249.     ' Blank the non-static colors.
  250.     For i = 0 To StaticColor1
  251.         palentry(i) = sys(i)
  252.     Next i
  253.     For i = StaticColor1 + 1 To StaticColor2 - 1
  254.         With palentry(i)
  255.             .peRed = 0
  256.             .peGreen = 0
  257.             .peBlue = 0
  258.             .peFlags = PC_NOCOLLAPSE
  259.         End With
  260.     Next i
  261.     For i = StaticColor2 To 255
  262.         palentry(i) = sys(i)
  263.     Next i
  264.     i = SetPaletteEntries(logpal, 0, SysPalSize, palentry(0))
  265.     ' Insert the non-static grays.
  266.     gray = 0
  267.     dgray = 255 / (StaticColor2 - StaticColor1 - 2)
  268.     For i = StaticColor1 + 1 To StaticColor2 - 1
  269.         c = gray
  270.         gray = gray + dgray
  271.         With palentry(i)
  272.             .peRed = c
  273.             .peGreen = c
  274.             .peBlue = c
  275.         End With
  276.     Next i
  277.     i = SetPaletteEntries(logpal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))
  278.     ' Recreate the image using the new colors.
  279.     For y = 1 To hgt
  280.         For x = 1 To wid
  281.             clr = bytes(x, y)
  282.             With sys(clr)
  283.                 c = (CInt(.peRed) + .peGreen + .peBlue) / 3
  284.             End With
  285.             bytes(x, y) = NearestNonstaticGray(c)
  286.         Next x
  287.     Next y
  288.     status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
  289.     ' Realize the gray palette.
  290.     i = RealizePalette(pic.hdc)
  291.     pic.Refresh
  292. End Sub
  293. Private Sub Form_Unload(Cancel As Integer)
  294.     End
  295. End Sub
  296. Private Sub mnuFileExit_Click()
  297.     Unload Me
  298. End Sub
  299.